home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _84032d9bebb401a0690319ab7df4e06b < prev    next >
Encoding:
Text File  |  2002-05-30  |  1.0 KB  |  53 lines
  1. package Tk::DragDrop::Win32Site;
  2.  
  3. use vars qw($VERSION);
  4. $VERSION = '3.008'; # $Id: //depot/Tk8/DragDrop/Win32Site/Win32Site.pm#8 $
  5.  
  6. use Tk qw($XS_VERSION);
  7. require DynaLoader;
  8. require Tk::DropSite;
  9.  
  10. use vars qw($VERSION);
  11. $VERSION = '3.008'; # $Id: //depot/Tk8/DragDrop/Win32Site/Win32Site.pm#8 $
  12.  
  13. use base qw(Tk::DropSite DynaLoader);
  14.  
  15. bootstrap Tk::DragDrop::Win32Site;
  16.  
  17. use strict;
  18.  
  19. Tk::DropSite->Type('Win32');
  20.  
  21. sub WM_DROPFILES () {563}
  22.  
  23. sub InitSite
  24. {
  25.  my ($class,$site) = @_;
  26.  my $w = $site->widget;
  27.  $w->BindClientMessage(WM_DROPFILES,[\&Win32Drop,$site]);
  28.  DragAcceptFiles($w,1);
  29.  # warn "Enable $w";
  30. }
  31.  
  32. sub Win32Drop
  33. {
  34.  # print join(',',@_),"\n";
  35.  my ($w,$site,$msg,$wParam,$lParam) = @_;
  36.  my ($x,$y,@files) = DropInfo($wParam);
  37.  my $cb = $site->{'-dropcommand'};
  38.  if ($cb)
  39.   {
  40.    foreach my $file (@files)
  41.     {
  42.      # print "$file @ $x,$y\n";
  43.      $w->clipboardClear;
  44.      $w->clipboardAppend('--',$file);
  45.      $cb->Call('CLIPBOARD',$x,$y);
  46.     }
  47.   }
  48.  return 0;
  49. }
  50.  
  51. 1;
  52. __END__
  53.